Consider the following data that reprents high school and college GPAs.

gpa <- data.frame(
  hsgpa = c(3.1, 2.3, 3, 2.5, 3.9, 2.25, 4, 3.8, 3.7, 3.3, 3.8, 3.6, 3.6, 3.3, 3.4, 3.4, 3, 2.9, 3.1, 3.5, 3.3, 2.6, 3, 3.6, 2),
cgpa = c(1.17, 2.24, 2.42, 1.8, 3.16, 1.18, 2.71, 3.52, 2.92, 3.4, 2.02,  3.38, 2.69, 3.04, 2.35, 2, 2.32, 2.48, 2.37, 3.14, 1.88, 2.17, 2.3, 2.18, 0)
)

gpa
plot(gpa)

Given this data, we want to know if there is a significant correlation between high school and college GPA.

(observed_value <- cor(gpa$hsgpa, gpa$cgpa))

[1] 0.684634
new_gpa <- data.frame(
  hsgpa = gpa$hsgpa,
  cgpa = sample(gpa$cgpa)
)

plot(new_gpa)

(new_gpa <- data.frame(hsgpa = gpa$hsgpa,
                      cgpa = sample(gpa$cgpa)))
n_permutations <- 10000
results <- replicate(n_permutations, {
  new_gpa <- data.frame(hsgpa = gpa$hsgpa, cgpa = sample(gpa$cgpa))
  cor(new_gpa$hsgpa, new_gpa$cgpa)
})
plot(density(results))
abline(v = observed_value, col = "red")

(p_value <- mean(abs(results) >= abs(observed_value)))
[1] 3e-04
ci <- p_value + c(-1, 1) * qnorm(.975) * sqrt(p_value * (1 - p_value) / n_permutations)
c(lower = ci[1],
  p_value = p_value,
  upper = ci[2])
        lower       p_value         upper 
-0.0000394248  0.0003000000  0.0006394248
LS0tCnRpdGxlOiAiSGlnaCBTY2hvb2wgYW5kIENvbGxlZ2UgR1BBIgpzdWJ0aXRsZTogIklzIHRoZXJlIGEgcmVsYXRpb25zaGlwPyIKb3V0cHV0OiBodG1sX25vdGVib29rCi0tLQoKYGBge3Igc2V0dXAsIGluY2x1ZGUgPSBGQUxTRX0Ka25pdHI6Om9wdHNfY2h1bmskc2V0KGNhY2hlID0gVFJVRSkKYGBgCgpDb25zaWRlciB0aGUgZm9sbG93aW5nIGRhdGEgdGhhdCByZXByZW50cyBoaWdoIHNjaG9vbCBhbmQgY29sbGVnZSBHUEFzLgoKYGBge3J9CmdwYSA8LSBkYXRhLmZyYW1lKAogIGhzZ3BhID0gYygzLjEsIDIuMywgMywgMi41LCAzLjksIDIuMjUsIDQsIDMuOCwgMy43LCAzLjMsIDMuOCwgMy42LCAzLjYsIDMuMywgMy40LCAzLjQsIDMsIDIuOSwgMy4xLCAzLjUsIDMuMywgMi42LCAzLCAzLjYsIDIpLApjZ3BhID0gYygxLjE3LCAyLjI0LCAyLjQyLCAxLjgsIDMuMTYsIDEuMTgsIDIuNzEsIDMuNTIsIDIuOTIsIDMuNCwgMi4wMiwgIDMuMzgsIDIuNjksIDMuMDQsIDIuMzUsIDIsIDIuMzIsIDIuNDgsIDIuMzcsIDMuMTQsIDEuODgsIDIuMTcsIDIuMywgMi4xOCwgMCkKKQoKZ3BhCmBgYAoKYGBge3J9CnBsb3QoZ3BhKQpgYGAKCkdpdmVuIHRoaXMgZGF0YSwgd2Ugd2FudCB0byBrbm93IGlmIHRoZXJlIGlzIGEgc2lnbmlmaWNhbnQgY29ycmVsYXRpb24gYmV0d2VlbgpoaWdoIHNjaG9vbCBhbmQgY29sbGVnZSBHUEEuCgorIENhbGN1bGF0ZSB0aGUgb2JzZXJ2ZWQgY29ycmVsYXRpb24gKGBjb3IoKWApCisgVXNlIGEgcGVybXV0YXRpb24gdGVzdCB0byBidWlsZCBhIGRpc3RyaWJ1dGlvbiBvZiB2YWx1ZXMgdW5kZXIgdGhlIG51bGwgaHlwb3RoZXNpcwoodGhlcmUgaXMgbm8gY29ycmVsYXRpb24pCisgVXNlIHRoaXMgZGlzdHJpYnV0aW9uIHRvIGRldGVybWluZSB0aGUgcCB2YWx1ZSBvZiB0aGUgb2JzZXJ2ZWQgY29ycmVsYXRpb24KKyBCdWlsZCBhIGNvbmZpZGVuY2UgaW50ZXJ2YWwgYXJvdW5kIHRoZSBwIHZhbHVlCgpgYGB7cn0KKG9ic2VydmVkX3ZhbHVlIDwtIGNvcihncGEkaHNncGEsIGdwYSRjZ3BhKSkKYGBgCgpgYGB7cn0KbmV3X2dwYSA8LSBkYXRhLmZyYW1lKAogIGhzZ3BhID0gZ3BhJGhzZ3BhLAogIGNncGEgPSBzYW1wbGUoZ3BhJGNncGEpCikKCnBsb3QobmV3X2dwYSkKYGBgCgoKYGBge3J9CihuZXdfZ3BhIDwtIGRhdGEuZnJhbWUoaHNncGEgPSBncGEkaHNncGEsCiAgICAgICAgICAgICAgICAgICAgICBjZ3BhID0gc2FtcGxlKGdwYSRjZ3BhKSkpCmBgYAoKCmBgYHtyfQpuX3Blcm11dGF0aW9ucyA8LSAxMDAwMApyZXN1bHRzIDwtIHJlcGxpY2F0ZShuX3Blcm11dGF0aW9ucywgewogIG5ld19ncGEgPC0gZGF0YS5mcmFtZShoc2dwYSA9IGdwYSRoc2dwYSwgY2dwYSA9IHNhbXBsZShncGEkY2dwYSkpCiAgY29yKG5ld19ncGEkaHNncGEsIG5ld19ncGEkY2dwYSkKfSkKYGBgCgpgYGB7cn0KcGxvdChkZW5zaXR5KHJlc3VsdHMpKQphYmxpbmUodiA9IG9ic2VydmVkX3ZhbHVlLCBjb2wgPSAicmVkIikKYGBgCgpgYGB7cn0KKHBfdmFsdWUgPC0gbWVhbihhYnMocmVzdWx0cykgPj0gYWJzKG9ic2VydmVkX3ZhbHVlKSkpCmBgYAoKYGBge3J9CmNpIDwtIHBfdmFsdWUgKyBjKC0xLCAxKSAqIHFub3JtKC45NzUpICogc3FydChwX3ZhbHVlICogKDEgLSBwX3ZhbHVlKSAvIG5fcGVybXV0YXRpb25zKQpjKGxvd2VyID0gY2lbMV0sCiAgcF92YWx1ZSA9IHBfdmFsdWUsCiAgdXBwZXIgPSBjaVsyXSkKYGBgCgo=